{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module FRP.Taupo
  ( SignalGraph,
    onDemand,
    onSupply,
    fillIn,
    schedule,
    scheduleMono,
    scheduleSemi,
    scheduleEarliest,
    scheduleLatest,
    batch,
    batchMono,
    batchSemi,
    batchEarliest,
    batchLatest,
    event,
    output,
  )
where

import Control.Foldl (Fold)
import qualified Control.Foldl as L
import Control.Selective (Selective (select))
import Data.Bifunctor (second)
import Data.Functor (void, ($>))
import Data.Kind (Type)
import Data.Maybe (fromJust)
import Data.Monoid (Alt (Alt), Dual (Dual), getAlt, getDual)
import Data.Semialign (Semialign (align, alignWith))
import Data.These (These)
import GHC.TypeNats (Nat, type (<=))

-- Separate design from implementation

-- Inputs (primitive signals):
--  * Mouse clicks (user from outside world, co-ordinates of click)
--  * Server responses (server from outside world, server data)
--  * Disk data loads (data from outside world, data from disk)
--
-- On-demand (happen when _we_ say) or on-supply (when they feel like it)
-- Outputs (changes, effects, etc):
--  * Rendering an image (send it some image data, draw it on the screen)
--  * Play a sound (send it sound data, play it through speakers)
--  * Notify the server (send it client data, beam it to the server)
--
-- Demand-driven (the output asks us and we deliver) or supply-driven (we give
-- it things, and it just has to deal)

-- We want to be able to _statically_ deal with scheduling differences.
--
-- Based on 'Rhine: FRP with Type-Level Clocks', by Baerenz and Perez.

-- Rescheduling can take two forms:
--
-- Faster schedule -> slower schedule (batching)
-- Slower schedule -> faster schedule (fill-in)
-- For smart batching, we need:
--  * 'Default' value
--  * 'Combining' two values into one value
--  * This can give us accumulation behaviour if we want it
--
-- Solution: Monoid!

-- _Structure_ of the signal graph
-- Generalized from 'The Haskell Layer Cake' by Matt Parsons.
data SignalGraph (eff :: Type -> Type) (freq :: Maybe Nat) (a :: Type) where
  -- Inputs
  OnDemand :: eff a -> SignalGraph eff ('Just hz) a
  OnSupply :: (a -> eff ()) -> (a -> b) -> SignalGraph eff 'Nothing b
  -- Reschedulers
  FillIn :: (Maybe a -> b) -> SignalGraph eff ('Just hz') a -> SignalGraph eff ('Just hz) b
  Batch :: Fold a b -> SignalGraph eff freq a -> SignalGraph eff ('Just hz) b
  -- Transformers
  Transform :: (a -> eff b) -> SignalGraph eff freq a -> SignalGraph eff freq b
  -- Combinations
  MuxSync :: (a -> b -> c) -> SignalGraph eff ('Just hz) a -> SignalGraph eff ('Just hz) b -> SignalGraph eff ('Just hz) c
  MuxAsync :: (These a b -> c) -> SignalGraph eff 'Nothing a -> SignalGraph eff 'Nothing b -> SignalGraph eff 'Nothing c
  Select :: SignalGraph eff ('Just hz) (Either a b) -> SignalGraph eff ('Just hz) (a -> b) -> SignalGraph eff ('Just hz) b

-- TODO: consider SelectAsync :: SignalGraph eff 'Nothing (These a b) ->
-- SignalGraph eff 'Nothing (a -> b) -> SignalGraph eff 'Nothing c

-- To the person defining the signal graph, this is what they see:

-- | sig | -- f --> | sig' | -- g --> | sig'' |
-- The reality:
-- | sig | -- f . g --> | sig '' |
instance (Functor eff) => Functor (SignalGraph eff freq) where
  -- fmap id = id
  -- implies
  -- fmap f . fmap g = fmap (f . g)
  fmap ::
    forall a b.
    (a -> b) ->
    SignalGraph eff freq a ->
    SignalGraph eff freq b
  fmap f = \case
    OnDemand act -> OnDemand (fmap f act)
    OnSupply act g -> OnSupply act (f . g)
    FillIn g sg -> FillIn (f . g) sg
    Batch fld sg -> Batch (fmap f fld) sg
    Transform g sg -> Transform (fmap f . g) sg
    MuxSync g sg1 sg2 -> MuxSync (\x -> f . g x) sg1 sg2
    MuxAsync g sg1 sg2 -> MuxAsync (f . g) sg1 sg2
    Select datSg ctrlSg -> Select (fmap (second f) datSg) (fmap (f .) ctrlSg)
  (<$) :: a -> SignalGraph eff freq b -> SignalGraph eff freq a
  (<$) x = \case
    OnDemand act -> OnDemand (act $> x)
    OnSupply act _ -> OnSupply act (const x)
    FillIn _ sg -> FillIn (const x) sg
    Batch fld sg -> Batch (x <$ fld) sg
    Transform g sg -> Transform (($> x) . g) sg
    MuxSync _ sg sg' -> MuxSync (\_ _ -> x) sg sg'
    MuxAsync _ sg sg' -> MuxAsync (const x) sg sg'
    Select datSg ctrlSg ->
      Select (fmap (second (const x)) datSg) (fmap (\_ _ -> x) ctrlSg)

-- Allows asynchronous product of signals
instance (Functor eff) => Semialign (SignalGraph eff 'Nothing) where
  align ::
    SignalGraph eff 'Nothing a ->
    SignalGraph eff 'Nothing b ->
    SignalGraph eff 'Nothing (These a b)
  align sg1 sg2 = MuxAsync id sg1 sg2
  alignWith ::
    (These a b -> c) ->
    SignalGraph eff 'Nothing a ->
    SignalGraph eff 'Nothing b ->
    SignalGraph eff 'Nothing c
  alignWith = MuxAsync

-- The composition of two Applicatives is an Applicative!
instance (Applicative eff) => Applicative (SignalGraph eff ('Just hz)) where
  pure :: a -> SignalGraph eff ('Just hz) a
  pure x = OnDemand . pure $ x
  (<*>) ::
    SignalGraph eff ('Just hz) (a -> b) ->
    SignalGraph eff ('Just hz) a ->
    SignalGraph eff ('Just hz) b
  sgf <*> sgx = MuxSync ($) sgf sgx

-- The composition of an Applicative and a Selective is a Selective!
instance (Selective eff) => Selective (SignalGraph eff ('Just hz)) where
  select ::
    SignalGraph eff ('Just hz) (Either a b) ->
    SignalGraph eff ('Just hz) (a -> b) ->
    SignalGraph eff ('Just hz) b
  select sigDat sigCtrl = case sigDat of
    OnDemand act -> case sigCtrl of
      OnDemand act' -> OnDemand (select act act')
      _ -> Select sigDat sigCtrl
    _ -> Select sigDat sigCtrl

onDemand :: eff a -> SignalGraph eff ('Just hz) a
onDemand = OnDemand

onSupply :: (a -> eff ()) -> SignalGraph eff 'Nothing a
onSupply f = OnSupply f id

fillIn ::
  (hz <= hz') =>
  (Maybe a -> b) ->
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') b
fillIn = FillIn

schedule ::
  Fold a b ->
  SignalGraph eff 'Nothing a ->
  SignalGraph eff ('Just hz) b
schedule = Batch

scheduleMono ::
  (Monoid m) =>
  (a -> m) ->
  SignalGraph eff 'Nothing a ->
  SignalGraph eff ('Just hz) m
scheduleMono f = Batch (L.foldMap f id)

scheduleSemi ::
  (Semigroup s) =>
  (a -> s) ->
  SignalGraph eff 'Nothing a ->
  SignalGraph eff ('Just hz) (Maybe s)
scheduleSemi f = Batch (L.foldMap (Just . f) id)

scheduleEarliest ::
  SignalGraph eff 'Nothing a ->
  SignalGraph eff ('Just hz) (Maybe a)
scheduleEarliest = Batch (L.foldMap (Alt . Just) getAlt)

scheduleLatest ::
  SignalGraph eff 'Nothing a ->
  SignalGraph eff ('Just hz) (Maybe a)
scheduleLatest = Batch (L.foldMap (Dual . Alt . Just) (getAlt . getDual))

batch ::
  (hz' <= hz) =>
  Fold a b ->
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') b
batch = Batch

batchMono ::
  (Monoid m, hz' <= hz) =>
  (a -> m) ->
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') m
batchMono f = Batch (L.foldMap f id)

batchSemi ::
  (Semigroup s, hz' <= hz) =>
  (a -> s) ->
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') s
batchSemi f = Batch (L.foldMap (Just . f) fromJust)

batchEarliest ::
  (hz' <= hz) =>
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') a
batchEarliest = Batch (L.foldMap (Alt . Just) (fromJust . getAlt))

batchLatest ::
  (hz' <= hz) =>
  SignalGraph eff ('Just hz) a ->
  SignalGraph eff ('Just hz') a
batchLatest = Batch (L.foldMap (Dual . Alt . Just) (fromJust . getAlt . getDual))

event ::
  (Functor eff) =>
  (a -> eff ()) ->
  SignalGraph eff freq a ->
  SignalGraph eff freq a
event f = Transform (\x -> f x $> x)

output ::
  (Functor eff) =>
  (a -> eff b) ->
  SignalGraph eff freq a ->
  SignalGraph eff freq ()
output f = Transform (void . f)

{-
import Control.Applicative (Applicative (liftA2))
import Control.Selective (Selective (select))
import Data.Bool (bool)

-- What is FRP, and why do we care?
--

-- * Mixture of synchronous and asynchronous components

-- * High contention

--
-- Common issues:
--

-- * _VERY_ complex

-- * Error-prone (Heisenbugs)

-- * Non-compositional

--
-- Haskellers _love_ being compositional!
--
-- _That_ is FRP (Functional Reactive Programming).
--
-- First introduced by Conal Elliot in 'Functional Reactive Animation'.
--
-- Conceptual model
--
-- 'How we see the world'.

-- In FRP, time is conceptually a dense, linear order:

-- * Equality between times

-- * <= which is transitive, anti-symmetric, total:

--    * For any t1, t2, t3, if t1 <= t2 and t2 <= t3, then t1 <= t3 (transitive)
--    * For any t1, t2, if t1 <= t2 and t2 <= t1, t1 == t2 (anti-symmetric)
--    * For any t1, t2, t1 <= t2 or t2 <= t1 (total)

-- * For any t1 /= t2, there exists t3 such that t1 < t3 < t2 (dense)

newtype Time = Time Rational -- Cantor's back-and-forth argument
  deriving (Eq, Ord, Num, Fractional) via Rational

-- Value that varies in time (with possible effects)
newtype Signal a = Signal (Time -> IO a)

-- fmap f sig:
--

-- | sig | -- f -> | sig' | (signal graph)
instance Functor Signal where
  -- fmap id = id
  fmap :: (a -> b) -> Signal a -> Signal b
  fmap f (Signal sig) = Signal (fmap f . sig)

--  | sig 1 | ----- | sig 2|
--              |
--              f
--              |
--              \/
--           | sig '|

instance Applicative Signal where
  pure :: a -> Signal a
  pure x = Signal $ const (pure x)
  liftA2 :: (a -> b -> c) -> Signal a -> Signal b -> Signal c
  liftA2 f (Signal sig1) (Signal sig2) =
    Signal $ \t -> liftA2 f (sig1 t) (sig2 t) -- _MUST_ produce all effects!

-- No branching!

{-
-- | control | -- f ---> | sig1 | (runtime rebuilding)
--                   --> | sig2 |
--                   --> | sig3 |
--                   --> ...
instance Monad Signal where
  (>>=) :: Signal a -> (a -> Signal b) -> Signal b
  Signal control >>= f = Signal $ \t -> do
    res <- control t
    let (Signal sig) = f res
    sig t

whenS :: Signal Bool -> Signal () -> Signal () -> Signal ()
whenS (Signal control) (Signal sigFalse) (Signal sigTrue) = Signal $ \t -> do
  res <- control t
  let sig =
        if res
          then sigTrue
          else sigFalse
  sig t

-- A _lot_ of problems with this!
--
-- 1. Inefficient in practice
-- 2. Separation of description and execution
--
-- This leads to the following conclusion:
--
-- In _theory_, monadic FRP is fine; in practice, it is unworkable.

-}

-- Signal transformers
--
-- Previous FRP is _first-order_: it's about signals.
--
-- Instead, we can think about _signal transformers_:
--
-- newtype SignalTransformer a b = SignalTransformer ((Time, a) -> IO b)
--
-- ... but this isn't what we're interested in.

-- Selective
--
-- From 'Selective Applicative Functors'.
-- Selective is a 'midway point' between Applicative and Monad.

-- | data | =====-=-= | ctrl |
--              |
--              ||
--              |
--              ||
--              \/
--            | sig |
instance Selective Signal where
  select :: Signal (Either a b) -> Signal (a -> b) -> Signal b
  select (Signal dataSig) (Signal ctrlSig) = Signal $ \t -> do
    res <- dataSig t
    case res of
      Left x -> do
        -- no new signal!
        ctrl <- ctrlSig t
        pure . ctrl $ x
      Right x -> pure x -- no new signal!

-- Control.Selective _provides_ whenS! So we have branching, yay!
-}
